home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #1 / Ham Radio 2000.iso / ham2000 / packet / p_aa4re / bb212src / bbfwdrl.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-16  |  21.4 KB  |  532 lines
  1. (*===========================================================================*)
  2. (* Forward task -- Handle messages whose path is to LEAVE, DONE, or ?        *)
  3. (*                                                                           *)
  4. (*   Copyright 1990, 1991 by H. Roy Engehausen.  All rights reserved.        *)
  5. (*                                                                           *)
  6. (*===========================================================================*)
  7.  
  8. {$UNDEF DEBUG_LEAVE}
  9.  
  10. PROCEDURE do_leave;
  11.  
  12.   VAR
  13.     age_pos       : BYTE;
  14.     done_sw       : BOOLEAN;
  15.     i             : BYTE;
  16.     j             : WORD;
  17.     last_route    : msg_r_ptr;
  18.     leave_sw      : BOOLEAN;
  19.     msg_age       : LONGINT;
  20.     next_route    : msg_r_ptr;
  21.     qmark_sw      : BOOLEAN;
  22.     route_kill_sw : BOOLEAN;
  23.     this_dr       : msg_dr_ptr;
  24.     this_flag     : msg_flag_type;
  25.     this_inx      : BYTE;
  26.     this_msg      : msg_index_ptr;
  27.     this_route    : msg_r_ptr;
  28.  
  29.   LABEL
  30.     go_next_msg,
  31.     leave_loop;
  32.  
  33.   (*=========================================================================*)
  34.   (* Subprocedure to set the minimum age of a message.                       *)
  35.   (*=========================================================================*)
  36.  
  37.   PROCEDURE set_msg_age;
  38.  
  39.     VAR
  40.       code       : INTEGER;
  41.       hours      : INTEGER;
  42.       hour_sum   : WORD;
  43.       word_max   : INTEGER;
  44.       word_no    : BYTE;
  45.       word_to_do : STRING[4];
  46.  
  47.     LABEL
  48.       iterate;
  49.  
  50.     BEGIN;
  51.  
  52.       (*---------------------------------------------------------------------*)
  53.       (* Initialize counters                                                 *)
  54.       (*---------------------------------------------------------------------*)
  55.  
  56.       msg_age := max_time;
  57.  
  58.       hour_sum := 0;
  59.  
  60.       (*---------------------------------------------------------------------*)
  61.       (* Get the number of words to test.  If none, we are done              *)
  62.       (*---------------------------------------------------------------------*)
  63.  
  64.       word_max := age_pos - 1;
  65.       IF word_max < 1 THEN EXIT;
  66.  
  67.       (*---------------------------------------------------------------------*)
  68.       (* Loop thru the words                                                 *)
  69.       (*---------------------------------------------------------------------*)
  70.  
  71.       word_no := word_max;
  72.       WHILE word_no > 0 DO
  73.         BEGIN;
  74.  
  75.           (*-----------------------------------------------------------------*)
  76.           (* Get the word to be evaulated and see if it is short enough      *)
  77.           (*-----------------------------------------------------------------*)
  78.  
  79.           word_to_do := SUBWORD(@this_route^.msg_r_info, word_no, 1);
  80.           IF LENGTH(word_to_do) > 3 THEN
  81.             GOTO iterate;
  82.  
  83.           (*-----------------------------------------------------------------*)
  84.           (* Evaluate the word                                               *)
  85.           (*-----------------------------------------------------------------*)
  86.  
  87.           VAL(word_to_do, hours, code);
  88.  
  89.           (*-----------------------------------------------------------------*)
  90.           (* Reject certain things                                           *)
  91.           (*-----------------------------------------------------------------*)
  92.  
  93.           IF code <> 0 THEN GOTO iterate;
  94.           IF hours < 0 THEN GOTO iterate;
  95.  
  96.           (*-----------------------------------------------------------------*)
  97.           (* The data is valid                                               *)
  98.           (*-----------------------------------------------------------------*)
  99.  
  100.           hour_sum := hour_sum + hours;
  101.  
  102.           (*-----------------------------------------------------------------*)
  103.           (* If there is no plus sign then data is absolute.  Compute        *)
  104.           (* minimum path age and we are done                                *)
  105.           (*-----------------------------------------------------------------*)
  106.  
  107.           IF word_to_do[1] <> '+' THEN
  108.             BEGIN;
  109.               msg_age := current_day_time - LONGINT(hours) * ticks_per_hour;
  110.               EXIT;
  111.             END;
  112.  
  113.           (*----------------------------------------------------------------*)
  114.           (* Loop end for loop thru each word                                *)
  115.           (*-----------------------------------------------------------------*)
  116.  
  117. iterate:
  118.  
  119.           DEC(word_no);
  120.  
  121.         END; (*----- End of loop thru words ---------------------------------*)
  122.  
  123.       (*---------------------------------------------------------------------*)
  124.       (* Compute the maximum path age and we are done                        *)
  125.       (*---------------------------------------------------------------------*)
  126.  
  127.       msg_age := current_day_time - LONGINT(hour_sum) * ticks_per_hour;
  128.  
  129.     END;
  130.  
  131.   (*=========================================================================*)
  132.   (* Main line                                                               *)
  133.   (*=========================================================================*)
  134.  
  135.   BEGIN;
  136.  
  137.     (*-----------------------------------------------------------------------*)
  138.     (* Initialize                                                            *)
  139.     (*-----------------------------------------------------------------------*)
  140.  
  141.     last_route := NIL;
  142.     this_route := msg_route_list;
  143.  
  144.     (*-----------------------------------------------------------------------*)
  145.     (* Look down all the routes                                              *)
  146.     (*-----------------------------------------------------------------------*)
  147.  
  148.     WHILE this_route <> NIL DO
  149.       BEGIN;
  150.  
  151.         {$IFDEF POINT_CHK}
  152.           test_pointer(this_route);
  153.         {$ENDIF}
  154.  
  155.         {$IFDEF DEBUG_LEAVE}
  156.           WRITELN('Process leave = ', this_route^.msg_r_info);
  157.           DELAY(2000);
  158.         {$ENDIF}
  159.  
  160.         (*-------------------------------------------------------------------*)
  161.         (* Point to next route                                               *)
  162.         (*-------------------------------------------------------------------*)
  163.  
  164.         next_route := this_route^.msg_r_next;
  165.  
  166.         (*-------------------------------------------------------------------*)
  167.         (* See if we need action                                             *)
  168.         (*-------------------------------------------------------------------*)
  169.  
  170.         i := 0;
  171.  
  172.         age_pos := FIND(@this_route^.msg_r_info, @done);
  173.         IF age_pos <> 0 THEN
  174.           BEGIN;
  175.             done_sw := TRUE;
  176.             INC(i);
  177.           END
  178.         ELSE
  179.           done_sw := FALSE;
  180.  
  181.         j := FIND(@this_route^.msg_r_info, @qmark);
  182.         IF j <> 0 THEN
  183.           BEGIN;
  184.             qmark_sw := TRUE;
  185.             age_pos  := j;
  186.             INC(i);
  187.           END
  188.         ELSE
  189.           qmark_sw := FALSE;
  190.  
  191.         leave_sw := FIND(@this_route^.msg_r_info, @leave) <> 0;
  192.         IF leave_sw THEN
  193.           INC(i);
  194.  
  195.         {$IFDEF DEBUG_LEAVE}
  196.           WRITELN('Leave actions = ', done_sw, ' ',
  197.                                       qmark_sw, ' ',
  198.                                       leave_sw, ' ');
  199.           DELAY(2000);
  200.         {$ENDIF}
  201.  
  202.         (*-------------------------------------------------------------------*)
  203.         (* Look for errors                                                   *)
  204.         (*-------------------------------------------------------------------*)
  205.  
  206.         IF i > 1 THEN
  207.           BEGIN;
  208.             window_write(prefix_str, 'Route line has multiple ?, DONE, LEAVE');
  209.             window_write(prefix_str, this_route^.msg_r_info);
  210.           END;
  211.  
  212.         (*-------------------------------------------------------------------*)
  213.         (* Now take appropriate action                                       *)
  214.         (*-------------------------------------------------------------------*)
  215.  
  216.         IF NOT (qmark_sw OR done_sw OR leave_sw) THEN
  217.  
  218.           (*-----------------------------------------------------------------*)
  219.           (* This route has none of the actions.  Just forward the chaining  *)
  220.           (*-----------------------------------------------------------------*)
  221.  
  222.           last_route := this_route
  223.         ELSE
  224.  
  225.           (*-----------------------------------------------------------------*)
  226.           (* Handle the action needed                                        *)
  227.           (*-----------------------------------------------------------------*)
  228.  
  229.           BEGIN;
  230.  
  231.             {$IFDEF DEBUG_LEAVE}
  232.               WRITELN('Leave process = ', this_route^.msg_r_info);
  233.               DELAY(2000);
  234.             {$ENDIF}
  235.  
  236.             (*---------------------------------------------------------------*)
  237.             (* Compute message age                                           *)
  238.             (*---------------------------------------------------------------*)
  239.  
  240.             set_msg_age;
  241.  
  242.             {$IFDEF DEBUG_LEAVE}
  243.               WRITELN('Action time = ', current_day_time - msg_age);
  244.               DELAY(2000);
  245.             {$ENDIF}
  246.  
  247.             (*---------------------------------------------------------------*)
  248.             (* Assume we throw away the route when done                      *)
  249.             (*---------------------------------------------------------------*)
  250.  
  251.             route_kill_sw := TRUE;
  252.  
  253.             (*---------------------------------------------------------------*)
  254.             (* Loop while we adjust the messages                             *)
  255.             (*---------------------------------------------------------------*)
  256.  
  257.             this_msg := NIL;
  258.  
  259.             WHILE TRUE DO
  260.               BEGIN;
  261.  
  262. go_next_msg:
  263.  
  264.                 (*-----------------------------------------------------------*)
  265.                 (* Find a message that this points to.  If we can't we are   *)
  266.                 (* done                                                      *)
  267.                 (*-----------------------------------------------------------*)
  268.  
  269.                 this_msg := find_next_msg(this_route, this_msg, this_inx);
  270.  
  271.                 IF this_msg = NIL THEN
  272.                   GOTO leave_loop;
  273.  
  274.                 {$IFDEF POINT_CHK}
  275.                   test_pointer(this_msg);
  276.                 {$ENDIF}
  277.  
  278.                 {$IFDEF DEBUG_LEAVE}
  279.                   WRITELN('Leave message = ', this_msg^.msg_i_mb.msg_number,
  280.                           '/', this_inx);
  281.                   DELAY(2000);
  282.                 {$ENDIF}
  283.  
  284.                 (*-----------------------------------------------------------*)
  285.                 (* If we are checking for done then check the message age    *)
  286.                 (* too.  If not old enough, skip the message and the route   *)
  287.                 (* is still good                                             *)
  288.                 (*-----------------------------------------------------------*)
  289.  
  290.                 IF this_msg^.msg_i_mb.msg_dt_in > msg_age THEN
  291.                   BEGIN;
  292.  
  293.                     {$IFDEF DEBUG_LEAVE}
  294.                       WRITELN('Age bypass');
  295.                       DELAY(2000);
  296.                     {$ENDIF}
  297.  
  298.                     route_kill_sw := FALSE;
  299.                     GOTO go_next_msg;
  300.  
  301.                   END;
  302.  
  303.                 (*-----------------------------------------------------------*)
  304.                 (* Get the flag into a handy place                           *)
  305.                 (*-----------------------------------------------------------*)
  306.  
  307.                 this_flag := this_msg^.msg_i_mb.msg_flag;
  308.  
  309.                 (*-----------------------------------------------------------*)
  310.                 (* If we are routing to "?" then set the flag                *)
  311.                 (*-----------------------------------------------------------*)
  312.  
  313.                 IF qmark_sw THEN
  314.                   this_flag := this_flag OR mf_unknown;
  315.  
  316.                 (*-----------------------------------------------------------*)
  317.                 (* Check for regular message or distribution list            *)
  318.                 (*-----------------------------------------------------------*)
  319.  
  320.                 IF this_inx = 0 THEN
  321.                   BEGIN;
  322.  
  323.                     (*-------------------------------------------------------*)
  324.                     (* Regular message.  Reset the route pointer and flag    *)
  325.                     (*-------------------------------------------------------*)
  326.  
  327.                     this_msg^.msg_i_rou := NIL;
  328.                     this_flag := this_flag
  329.                                      AND NOT (mf_fwd_select OR mf_fwd_process);
  330.  
  331.                     {$IFDEF DEBUG_LEAVE}
  332.                       WRITELN('Reset main flag');
  333.                       DELAY(2000);
  334.                     {$ENDIF}
  335.  
  336.                     (*-------------------------------------------------------*)
  337.                     (* If DONE then say so                                   *)
  338.                     (*-------------------------------------------------------*)
  339.  
  340.                     IF done_sw THEN
  341.                       BEGIN;
  342.                         this_flag := this_flag OR mf_fwd;
  343.                         IF POS(this_msg^.msg_i_mb.msg_type,
  344.                                                 opt_block.nofwd_kill) = 0 THEN
  345.                           this_flag := this_flag OR mf_kill
  346.                       END;
  347.  
  348.                   END
  349.                 ELSE
  350.  
  351.                   (*---------------------------------------------------------*)
  352.                   (* Distribution list.  We will only process things         *)
  353.                   (* if the distribution route list is also present.         *)
  354.                   (* It should be impossible to get here if it ain't         *)
  355.                   (*---------------------------------------------------------*)
  356.  
  357.                   IF (this_flag AND mf_disrout) <> 0 THEN
  358.                     BEGIN;
  359.  
  360.                       {$IFDEF DEBUG_LEAVE}
  361.                         WRITELN('Reset dist flag');
  362.                         DELAY(2000);
  363.                       {$ENDIF}
  364.  
  365.                       (*-----------------------------------------------------*)
  366.                       (* Get pointer to distribution route block             *)
  367.                       (*-----------------------------------------------------*)
  368.  
  369.                       this_dr := this_msg^.msg_i_dr;
  370.  
  371.                       {$IFDEF POINT_CHK}
  372.                         test_pointer(this_dr);
  373.                       {$ENDIF}
  374.  
  375.                       (*-----------------------------------------------------*)
  376.                       (* Now get pointer to distribution block               *)
  377.                       (*-----------------------------------------------------*)
  378.  
  379.                       {$IFDEF POINT_CHK}
  380.                         test_pointer(this_dr^.msg_dr_dblk);
  381.                       {$ENDIF}
  382.  
  383.                       (*-----------------------------------------------------*)
  384.                       (* Change the flags for this item                      *)
  385.                       (*-----------------------------------------------------*)
  386.  
  387.                       WITH this_dr^.msg_dr_dblk^.msg_d_array[this_inx] DO
  388.                         BEGIN;
  389.  
  390.                           (*-------------------------------------------------*)
  391.                           (* Reset the forward flags                         *)
  392.                           (*-------------------------------------------------*)
  393.  
  394.                           msg_d_flag := msg_d_flag AND
  395.                                      ($FF - (df_fwd_select OR df_fwd_process));
  396.  
  397.                           (*-------------------------------------------------*)
  398.                           (* Turn on "?" if needed                           *)
  399.                           (*-------------------------------------------------*)
  400.  
  401.                           IF qmark_sw THEN
  402.                             msg_d_flag := msg_d_flag OR df_fwd_unknown;
  403.  
  404.                           (*-------------------------------------------------*)
  405.                           (* Turn on "DONE" if needed                        *)
  406.                           (*-------------------------------------------------*)
  407.  
  408.                           IF done_sw THEN
  409.                             msg_d_flag := msg_d_flag OR df_fwd;
  410.  
  411.                         END;
  412.  
  413.                       (*-----------------------------------------------------*)
  414.                       (* See if we still are going to send this message out  *)
  415.                       (*-----------------------------------------------------*)
  416.  
  417.                       i := 1;
  418.                       j := this_dr^.msg_dr_dblk^.msg_d_no;
  419.                       WHILE (i <= j) AND (this_dr^.msg_dr_data[i] = NIL) DO
  420.                         INC(i);
  421.  
  422.                       {$IFDEF DEBUG_LEAVE}
  423.                         WRITELN('Dist block clean -- ', i ,'/', j);
  424.                         DELAY(2000);
  425.                       {$ENDIF}
  426.  
  427.                       (*-----------------------------------------------------*)
  428.                       (* If we aren't, then we can free things               *)
  429.                       (*-----------------------------------------------------*)
  430.  
  431.                       IF i > j THEN
  432.                         BEGIN;
  433.  
  434.                           (*-------------------------------------------------*)
  435.                           (* Unchain the distribution route block            *)
  436.                           (*-------------------------------------------------*)
  437.  
  438.                           this_msg^.msg_i_dis := this_dr^.msg_dr_dblk;
  439.  
  440.                           (*-------------------------------------------------*)
  441.                           (* Calculate size of the block and free it         *)
  442.                           (*-------------------------------------------------*)
  443.  
  444.                           j := j * SIZEOF(msg_dr_route_item)
  445.                                                          + SIZEOF(msg_d_ptr);
  446.                           FREEMEM(this_dr, j);
  447.  
  448.                           {$IFDEF DEBUG_LEAVE}
  449.                             WRITELN('Dist block free -- ', j);
  450.                             DELAY(2000);
  451.                           {$ENDIF}
  452.  
  453.                           {$IFDEF FREE_CHK}
  454.                             test_free_list;
  455.                           {$ENDIF}
  456.  
  457.                           (*-------------------------------------------------*)
  458.                           (* Turn off appropriate flags                      *)
  459.                           (*-------------------------------------------------*)
  460.  
  461.                           this_flag := this_flag
  462.                                            AND NOT (mf_disrout
  463.                                                     OR mf_fwd_select
  464.                                                     OR mf_fwd_process);
  465.  
  466.                         END; (*----- End handling distribution list cleanup -*)
  467.  
  468.                     END; (*----- End handling distribution list -------------*)
  469.  
  470.                 (*-----------------------------------------------------------*)
  471.                 (* Put the flag back                                         *)
  472.                 (*-----------------------------------------------------------*)
  473.  
  474.                 this_msg^.msg_i_mb.msg_flag := this_flag;
  475.  
  476.                 (*-----------------------------------------------------------*)
  477.                 (* If we did a permanent change then make it permanent       *)
  478.                 (*-----------------------------------------------------------*)
  479.  
  480.                 IF done_sw THEN
  481.                   BEGIN;
  482.                     update_msg(this_msg);
  483.                     IF (this_flag AND mf_kill) <> 0 THEN
  484.                       log_data_is(this_msg^.msg_i_mb.msg_number, 'FK DONE')
  485.                     ELSE
  486.                       log_data_is(this_msg^.msg_i_mb.msg_number, 'F DONE');
  487.                   END;
  488.  
  489.               END; (*----- End loop thru all the messages for this route ----*)
  490.  
  491. leave_loop:
  492.  
  493.             (*---------------------------------------------------------------*)
  494.             (* See if we are done with this route block                      *)
  495.             (*---------------------------------------------------------------*)
  496.  
  497.             IF route_kill_sw THEN
  498.               BEGIN;
  499.  
  500.                 (*-----------------------------------------------------------*)
  501.                 (* Unchain it from the list                                  *)
  502.                 (*-----------------------------------------------------------*)
  503.  
  504.                 IF last_route <> NIL THEN
  505.                   last_route^.msg_r_next := next_route
  506.                 ELSE
  507.                   msg_route_list := next_route;
  508.  
  509.                 (*-----------------------------------------------------------*)
  510.                 (* Destroy this route block                                  *)
  511.                 (*-----------------------------------------------------------*)
  512.  
  513.                 DISPOSE(this_route);
  514.  
  515.                 {$IFDEF FREE_CHK}
  516.                   test_free_list;
  517.                 {$ENDIF}
  518.  
  519.               END;
  520.  
  521.           END; (*----- End handling LEAVE, DONE,  and "?" -------------------*)
  522.  
  523.         (*-------------------------------------------------------------------*)
  524.         (* Chain to next route                                               *)
  525.         (*-------------------------------------------------------------------*)
  526.  
  527.         this_route := next_route;
  528.  
  529.       END; (*----- end loop thru all the routes -----------------------------*)
  530.  
  531.   END;
  532.